home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / boxer / boxer.lha / sprite.lisp < prev    next >
Encoding:
Text File  |  1993-07-17  |  8.5 KB  |  229 lines
  1. ;; -*- Mode:LISP; Package:(BOXER GLOBAL 1000); Fonts:cptfont,cptfontb; Base:10. -*-
  2. #|
  3.             Copyright 1985 Massachusetts Institute of Technology
  4.  
  5.  Permission to use, copy, modify, distribute, and sell this software
  6.  and its documentation for any purpose is hereby granted without fee,
  7.  provided that the above copyright notice appear in all copies and that
  8.  both that copyright notice and this permission notice appear in
  9.  supporting documentation, and that the name of M.I.T. not be used in
  10.  advertising or publicity pertaining to distribution of the software
  11.  without specific, written prior permission.  M.I.T. makes no
  12.  representations about the suitability of this software for any
  13.  purpose.  It is provided "as is" without express or implied warranty.
  14.  
  15.  
  16.                                           +-Data--+
  17.                  This file is part of the | BOXER | system
  18.                                           +-------+
  19.  
  20.  
  21.   This File contains the Definition of Sprite boxes
  22.  
  23.                                                                   by Jeremy
  24.  
  25. |#
  26.  
  27.  
  28. (defmethod (sprite-box :type) ()
  29.   ':sprite-box)
  30.  
  31. (defun make-initialized-sprite-box (&rest init-plist)
  32.   (instantiate-flavor 'sprite-box (locf init-plist) t))
  33.  
  34. (defun make-sprite-box (&OPTIONAL EXISTING-TURTLE)
  35.   (let* ((xpos (make-box '((0.))))
  36.      (ypos (make-box '((0.))))
  37.      (heading (make-box '((0.))))
  38.      (rows (list (make-row (list xpos ypos) NIL)
  39.              (make-row (ncons heading) NIL)))
  40.      (turtle (OR EXISTING-TURTLE (make-turtle)))
  41.      (box (make-initialized-sprite-box ':type ':sprite-box
  42.                        ':associated-turtle turtle)))
  43.     (tell turtle :set-sprite-box box)
  44.     (tell xpos :set-name (make-name-row '(xpos)))
  45.     (tell ypos :set-name (make-name-row '(ypos)))
  46.     (tell heading :set-name (make-name-row '(heading)))
  47.     (tell box :set-first-inferior-row nil)
  48.     (tell box :add-static-variable-pair 'bu:xpos xpos)
  49.     (tell box :add-static-variable-pair 'bu:ypos ypos)
  50.     (tell box :add-static-variable-pair 'bu:heading heading)
  51.     (dolist (row rows)
  52.       (tell box :append-row row))
  53.     box))
  54.  
  55.  
  56. (defmethod (sprite-box :before :init) (init-plist)
  57.   (unless (get init-plist ':type)
  58.     (putprop init-plist ':sprite-box ':type)))
  59.  
  60. ;(defmethod (sprite-box :copy) (&optional (with-name? nil))
  61. ;  (let* ((turtle (make-turtle))
  62. ;     (new-box (make-initialized-sprite-box ':associated-turtle turtle)))
  63. ;    (tell turtle :Set-sprite-box new-box)
  64. ;    new-box))
  65.  
  66. (DEFMETHOD (sprite-box :COPY) ()
  67.   (LET ((NEW-BOX (MAKE-initialized-sprite-BOX
  68.            ':associated-turtle (tell associated-turtle :copy)))
  69.     (BOX-STREAM (MAKE-BOX-STREAM SELF)))
  70.     (TELL NEW-BOX :SET-CONTENTS-FROM-STREAM BOX-STREAM T)
  71.     (WHEN (NOT-NULL PORTS)
  72.       (PUSH (CONS SELF NEW-BOX) .LINK-TARGET-ALIST.))
  73.     (tell (tell new-box :associated-turtle) :set-sprite-box new-box)
  74.     NEW-BOX))
  75.  
  76. (defmethod (sprite-box :add-graphics-object) (turtle)
  77.   (tell associated-turtle :add-subturtle turtle))
  78.  
  79. (defmethod (sprite-box :remove-graphics-object) (turtle)
  80.   (tell associated-turtle :remove-subturtle turtle))
  81.  
  82. (defmethod (sprite-box :toggle-type) () (beep))
  83.  
  84. ;;; The next two messages hookup sprite boxes and graphics boxes.
  85.  
  86. (defmethod (sprite-box :before :delete-self-action) ()
  87.   (let ((surrounding-box (tell self :superior-box)))
  88.     (when (or (graphics-data-box? surrounding-box)
  89.           (graphics-box? surrounding-box)
  90.           (sprite-box? surrounding-box))          
  91.        (tell surrounding-box :remove-graphics-object associated-turtle))))
  92.  
  93. (defmethod (sprite-box :after :insert-self-action) ()
  94.   (let ((surrounding-box (tell self :superior-box)))
  95.     (when (or (graphics-data-box? surrounding-box)
  96.           (graphics-box? surrounding-box)
  97.           (sprite-box? surrounding-box))
  98.       (tell surrounding-box :add-graphics-object associated-turtle))))
  99.  
  100.  
  101. (defun single-number-p (elt-list)
  102.   (and (= (length elt-list) 1)
  103.        (numberp (car elt-list))))
  104.  
  105. (defun double-number-p (elt-list)
  106.   (and (= (length elt-list) 2)
  107.        (numberp (car elt-list))
  108.        (numberp (cadr elt-list))))
  109.  
  110. (defmethod (box :clear-and-insert-stuff) (&rest stuff)
  111.   (tell self :set-first-inferior-row nil)
  112.   (tell self :append-row (make-row stuff))
  113.   (tell self :modified))
  114.  
  115.  
  116. ;;; This is the magic message which should be called every time 
  117. ;;; a sprite box instance variable might be changed by boxer.
  118.  
  119. (defmethod (box :exit-from-sprite-instance-var) ()
  120.   (let ((superior-box (tell self :superior-box)))
  121.     (when (sprite-box? superior-box)
  122.       (let ((elts (tell self :elements))
  123.         (MY-NAME (TELL SELF :NAME))
  124.         (turtle (tell superior-box :associated-turtle)))
  125.        (when (not-null (tell turtle :assoc-graphics-box))
  126.         (cond
  127.           ((STRING-EQUAL "who-line" MY-NAME)
  128.            (LET ((ST (SEND SELF :TEXT-STRING)))
  129.          (IF (EQ "" ST)
  130.              (SEND SUPERIOR-BOX :REMPROP :WHO-LINE)
  131.              (SEND SUPERIOR-BOX :PUTPROP ST :WHO-LINE))))
  132.           ((string-equal "xpos" my-name)
  133.            (if (single-number-p elts)
  134.            (tell turtle
  135.              :move-to (car elts) (tell turtle :y-position))
  136.            (tell self :clear-and-insert-stuff (tell turtle :x-position))))
  137.           ((string-equal "ypos" my-name)
  138.            (if (single-number-p elts)
  139.            (tell turtle
  140.              :move-to (tell turtle :x-position) (car elts))
  141.            (tell self :clear-and-insert-stuff (tell turtle :y-position))))
  142.           ((string-equal "heading" my-name)
  143.            (if (single-number-p elts)         
  144.            (tell turtle :set-heading (car elts))
  145.            (tell self :clear-and-insert-stuff (tell turtle :heading))))
  146.           ((string-equal "size" my-name)
  147.            (if (single-number-p elts)
  148.            (tell turtle :set-size (car elts))
  149.            (tell self :clear-and-insert-stuff (tell turtle :size))))
  150.           ((string-equal "shown" my-name)
  151.            (if (and (= (length elts) 1)
  152.             (memq (car elts) '(bu:none bu:all
  153.                       bu:subsprites bu:no-subsprites
  154.                       bu:true bu:false)))
  155.            (tell turtle :set-shown-p (car elts))
  156.            (tell self :clear-and-insert-stuff (tell turtle :shown-p-symbol))))
  157.           ((string-equal "origin" my-name)
  158.            (if (double-number-p elts)
  159.            (tell turtle :set-home (first elts) (second elts)))
  160.            (tell self :clear-and-insert-stuff
  161.              (tell turtle :home-x)
  162.              (tell turtle :home-y)))
  163.           ((string-equal "shape" my-name)
  164.            (tell turtle :set-shape-from-box self));;; should try to catch errors here!
  165.           ((string-equal "pen" my-name)
  166.            (if (and (= (length elts) 1)
  167.             (memq (car elts) '(bu:up bu:xor bu:erase bu:down)))
  168.            (tell turtle :set-pen (car elts))
  169.            (tell self :clear-and-insert-stuff (tell turtle :pen))))))))))
  170.  
  171. (defmethod (port-box :after :exit) (&rest ignore)
  172.   (tell ports :exit-from-sprite-instance-var))
  173.  
  174. ;;; This hooks up sprite state variables
  175.  
  176. (defmethod (sprite-box :after :add-static-variable-pair) (var value)
  177.   (selectq var
  178.     ((bu:shape)
  179.      (tell associated-turtle :add-shape-box value))
  180.     ((bu:size)
  181.      (tell associated-turtle :add-size-box value))
  182.     ((bu:xpos)
  183.      (tell associated-turtle :add-xpos-box value))
  184.     ((bu:ypos)
  185.      (tell associated-turtle :add-ypos-box value))
  186.     ((bu:heading)
  187.      (tell associated-turtle :add-heading-box value))
  188.     ((bu:pen)
  189.      (tell associated-turtle :add-pen-box value))
  190.     ((bu:origin)
  191.      (tell associated-turtle :Add-home-box value))
  192.     ((bu:shown)
  193.      (tell associated-turtle :add-shown-p-box value)))
  194.   (when (box? value) (tell value :exit-from-sprite-instance-var)))
  195.  
  196. (defmethod (sprite-box :after :remove-all-static-bindings) (value)
  197.   (multiple-value-bind (value-name ignore) (tell value :name)
  198.     (setq value-name (string-downcase value-name))
  199.     (cond 
  200.       ((equal "size" value-name)
  201.        (tell associated-turtle :remove-size-box))
  202.       ((equal "xpos" value-name)
  203.        (tell associated-turtle :remove-xpos-box))
  204.       ((equal "ypos" value-name)
  205.        (tell associated-turtle :remove-ypos-box))
  206.       ((equal "heading" value-name)
  207.        (tell associated-turtle :remove-heading-box))
  208.       ((equal "origin" value-name)
  209.        (tell associated-turtle :remove-home-box))
  210.       ((equal "pen" value-name)
  211.        (tell associated-turtle :remove-pen-box))
  212.       ((equal "shape" value-name)
  213.        (tell associated-turtle :remove-shape-box))
  214.       ((equal "shown" value-name)
  215.        (tell associated-turtle :remove-shown-p-box)))))
  216.  
  217. (DEFMETHOD (SPRITE-BOX :AFTER :REMOVE-STATIC-VARIABLE) (VARIABLE)
  218.   (WHEN (EQ VARIABLE 'BU:WHO-LINE)
  219.     (SEND SELF :REMPROP :WHO-LINE)))
  220.  
  221. (defboxer-function update ()
  222.   (let ((boxes (with-collection
  223.          (dolist (r (tell (tell-named-sprite :sprite-box) :rows))
  224.            (do-row-chas ((c r))
  225.              (when (box? c) (collect c)))))))
  226.     (dolist (b boxes)
  227.       (when (equal (tell b :name) "SHAPE")
  228.     (tell b :exit-from-sprite-instance-var)))))
  229.